home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / Debian / DictionariesCommon.pm < prev   
Encoding:
Perl POD Document  |  2009-05-15  |  17.1 KB  |  586 lines
  1. #!/usr/bin/perl
  2.  
  3. package Debian::DictionariesCommon;
  4.  
  5. use base qw(Exporter);
  6. use Text::Iconv;
  7.  
  8. # List all exported symbols here.
  9. our @EXPORT_OK = qw(parseinfo updatedb loaddb
  10.             dico_checkroot
  11.             dc_get_spellchecker_params
  12.             getlibdir getsysdefault setsysdefault
  13.             getuserdefault setuserdefault
  14.             build_emacsen_support
  15.             build_jed_support
  16.             build_squirrelmail_support
  17.             );
  18. # Import :all to get everything.
  19. our %EXPORT_TAGS = (all => [@EXPORT_OK]);
  20.  
  21. my $infodir             = "/var/lib/dictionaries-common";
  22. my $cachedir            = "/var/cache/dictionaries-common";
  23. my $ispelldefault       = "ispell-default";
  24. my $sysdefault          = "/etc/dictionaries-common/$ispelldefault";
  25. my $userdefault         = "$ENV{HOME}/.$ispelldefault";
  26. my $emacsensupport      = "emacsen-ispell-dicts.el";
  27. my $jedsupport          = "jed-ispell-dicts.sl";
  28. my $squirrelmailsupport = "sqspell.php";
  29.  
  30. sub dico_checkroot {
  31.   return if ($> == 0 or ($^O eq 'interix' and $> == 197108));
  32.   die "$0: You must run this as root.\n";
  33. }
  34.  
  35. sub getlibdir {
  36.   my $class = shift;
  37.   return "$infodir/$class";
  38. }
  39.  
  40. sub mydie {
  41.   my $routine = shift;
  42.   my $errmsg = shift;
  43.   die __PACKAGE__, "($routine):E: $errmsg";
  44. }
  45.  
  46. sub parseinfo {
  47.   my $file = shift;
  48.   local $/ = "";    # IRS is global, we need 'local' here, not 'my'
  49.   open (DICT, "< $file");
  50.   my %dictionaries =
  51.     map {
  52.       s/^([^:]+):/lc ($1) . ":"/meg;  # Lower case field names
  53.       my %hash = /^([^:]+):\s*((?<!\n)[^\n]+)\s*$/mg;
  54.       map { delete $hash{$_} if ($hash{$_} =~ /^\s+$/) } keys %hash;
  55.       mydie ('parseinfo',
  56.          qq{Record in file $file does not have a "Language" entry})
  57.     if not exists $hash{language};
  58.       mydie ('parseinfo',
  59.          qq{Record in file $file does not have a "Hash-Name" entry})
  60.     if not exists $hash{"hash-name"};
  61.       my $lang = delete $hash{language};
  62.       ($lang, \%hash);
  63.     } <DICT>;
  64.   return \%dictionaries;
  65. }
  66.  
  67. # ------------------------------------------------------------------
  68. sub dc_dumpdb {
  69. # ------------------------------------------------------------------
  70. # Save %dictionaries in Data::Dumper like format. This function
  71. # should be enough for the limited needs of dictionaries-common
  72. # ------------------------------------------------------------------
  73.   my $class        = shift;
  74.   my $dictionaries = shift;
  75.   my @fullarray    = ();
  76.   my @dictarray    = ();
  77.   my $output       = "$cachedir/$class.db";
  78.   my $dictentries  = '';
  79.   my $thevalue     = '';
  80.  
  81.   foreach $thedict ( sort keys %{$dictionaries}){
  82.     $dictentries = $dictionaries->{$thedict};
  83.     @dictarray   = ();
  84.     foreach $thekey ( sort keys %{$dictentries}){
  85.       $thevalue = $dictentries->{$thekey};
  86.       # Make sure \ and ' are escaped in keyvals
  87.       $thevalue =~ s/(\\|\')/\\$1/g;
  88.       push (@dictarray,"     \'$thekey\' => \'$thevalue\'");
  89.     }
  90.     # Make sure \ and ' are escaped in dict names
  91.     $thedict =~ s/(\\|\')/\\$1/g;
  92.     push (@fullarray,
  93.       "  \'$thedict\' => \{\n" . join(",\n",@dictarray) . "\n  \}");
  94.   }
  95.  
  96.   mkdir $cachedir unless (-d $cachedir);
  97.  
  98.   open (DB,"> $output");
  99.   print DB generate_comment("### ") . "\n";
  100.   print DB "%dictionaries = (\n";
  101.   print DB join (",\n",@fullarray);
  102.   print DB "\n);\n\n1;\n";
  103.   close DB;
  104. }
  105.  
  106. # ------------------------------------------------------------------
  107. sub dc_get_spellchecker_params {
  108. # ------------------------------------------------------------------
  109. # dc_get_spellchecker_params($class,\%language)
  110. #  Get right params for $class (currently unused) and $language
  111. # ------------------------------------------------------------------
  112.   my $class       = shift;
  113.   my $language    = shift;
  114.   my $d_option    = "";
  115.   my $w_option    = "";
  116.   my $T_option    = "";
  117.   my $ispell_args = "";
  118.  
  119.   $d_option = "-d $language->{'hash-name'}"
  120.       if exists $language->{'hash-name'};
  121.   $w_option = "-w $language->{'additionalchars'}"
  122.       if exists $language->{'additionalchars'};
  123.  
  124.   if ( exists $language->{'extended-character-mode'} ){
  125.     $T_option =  $language->{'extended-character-mode'};
  126.     $T_option =~ s/^~//; # Strip leading ~ from Extended-Character-Mode.
  127.     $T_option =  '-T ' . $T_option;
  128.   }
  129.  
  130.   if ( exists $language->{'ispell-args'} ){
  131.     $ispell_args = $language->{'ispell-args'};
  132.     foreach ( split('\s+',$ispell_args) ) {
  133.       # No d_option if already in $ispell_args
  134.       $d_option = "" if /^\-d/;
  135.     }
  136.   }
  137.   return "$d_option $w_option $T_option $ispell_args";
  138. }
  139.  
  140. # ------------------------------------------------------------------
  141. sub updatedb {
  142. # ------------------------------------------------------------------
  143. # Parse info files for the given class and update class database
  144. # ------------------------------------------------------------------
  145.   my $class        = shift;
  146.   my %dictionaries = ();
  147.  
  148.   foreach my $file (<$infodir/$class/*>) {
  149.     next if $file =~ m/.*~$/;                 # Ignore ~ backup files
  150.     my $dicts = &parseinfo ("$file");
  151.     %dictionaries = (%dictionaries, %$dicts);
  152.   }
  153.   &dc_dumpdb($class,\%dictionaries);
  154. }
  155.  
  156. sub loaddb {
  157.   my $class  = shift;
  158.   my $dbfile = "$cachedir/$class.db";
  159.   if (-e $dbfile) {
  160.     do $dbfile;
  161.   }
  162.   return \%dictionaries;
  163. }
  164.  
  165. sub getdefault {
  166.   $file = shift;
  167.   if (-f $file) {
  168.     my $lang = `cat $file`;
  169.     chomp $lang;
  170.     return $lang;
  171.   }
  172.   else {
  173.     return undef;
  174.   }
  175. }
  176.  
  177. sub getuserdefault {
  178.   getdefault ($userdefault);
  179. }
  180.  
  181. sub getsysdefault {
  182.   getdefault ($sysdefault);
  183. }
  184.  
  185. sub setsysdefault {
  186.   $value = shift;
  187.   open (DEFAULT, "> $sysdefault");
  188.   print DEFAULT $value;
  189.   close DEFAULT;
  190. }
  191.  
  192. sub setuserdefault {
  193.   my $default      = getuserdefault ();
  194.   my $dictionaries = loaddb ("ispell");
  195.   my @choices      = sort keys %$dictionaries;
  196.  
  197.   if (scalar @choices == 0) {
  198.     warn "Sorry, no ispell dictionary is installed in your system.\n";
  199.     return;
  200.   }
  201.  
  202.   my $initial = -1;
  203.   if (defined $default) {
  204.     for (my $i = 0; $i < scalar @choices; $i++) {
  205.       if ($default eq $choices[$i]) {
  206.     $initial = $i;
  207.     last;
  208.       }
  209.     }
  210.   }
  211.  
  212.   open (TTY, "/dev/tty");
  213.   while (1) {
  214.     $| = 1;
  215.     print
  216.       "\nSelect your personal ispell dictionary for use with ispell-wrapper\n\n";
  217.     for ($i = 0; $i < scalar @choices; $i++) {
  218.       print "  " . ($i == $initial ? "*" : " ")
  219.          . " [" . ($i+1) . "] $choices[$i]\n";
  220.     }
  221.     print qq(\nSelect number or "q" for quit)
  222.       . ($initial != -1 ? " (* is the current default): " : ": ");
  223.     my $sel = <TTY>;
  224.     chomp $sel;
  225.     last if $sel eq "q";
  226.     if ($sel < 1 or $sel > scalar @choices) {
  227.       print qq{\nInvalid choice "$sel".\n\n};
  228.       next;
  229.     }
  230.     else {
  231.       $sel--;
  232.       open (DEFAULT, "> $userdefault");
  233.       print DEFAULT $choices[$sel];
  234.       close DEFAULT;
  235.       last;
  236.     }
  237.   }
  238.   close TTY;
  239. }
  240.  
  241. sub generate_comment {
  242.   my $commstr = shift;
  243.   my $comment = "This file is part of the dictionaries-common package.
  244. It has been automatically generated.
  245. DO NOT EDIT!";
  246.   $comment =~ s{^}{$commstr}mg;
  247.   return "$comment\n";
  248. }
  249.  
  250. # ------------------------------------------------------------------
  251. sub build_emacsen_support {
  252. # ------------------------------------------------------------------
  253. # Put info from dicts info files into emacsen-ispell-dicts.el
  254. # ------------------------------------------------------------------
  255.   my $elisp          = '';
  256.   my @classes        = ("aspell","hunspell","ispell");
  257.   my %entries        = ();
  258.   my %class_locales  = ();
  259.  
  260.   foreach $class ( @classes ){
  261.     my $dictionaries = loaddb ($class);
  262.  
  263.     foreach $k (keys %$dictionaries) {
  264.       my $lang = $dictionaries->{$k};
  265.  
  266.       next if (exists $lang->{'emacs-display'}
  267.            && $lang->{'emacs-display'} eq "no");
  268.  
  269.       my $hashname = $lang->{"hash-name"};
  270.       my $casechars = exists $lang->{casechars} ?
  271.       $lang->{casechars} : "[a-zA-Z]";
  272.       my $notcasechars = exists $lang->{"not-casechars"} ?
  273.       $lang->{"not-casechars"} : "[^a-zA-Z]";
  274.       my $otherchars = exists $lang->{otherchars} ?
  275.       $lang->{otherchars} : "[']";
  276.       my $manyothercharsp = exists $lang->{"many-otherchars"} ?
  277.       ($lang->{"many-otherchars"} eq "yes" ? "t" : "nil") : "nil";
  278.       my $ispellargs = exists $lang->{"ispell-args"} ?
  279.       $lang->{"ispell-args"} : "-d $hashname";
  280.       my $extendedcharactermode = exists $lang->{"extended-character-mode"} ?
  281.       ('"' . $lang->{"extended-character-mode"} . '"') : "nil";
  282.       my $codingsystem = exists $lang->{"coding-system"} ?
  283.       $lang->{"coding-system"} : "nil";
  284.       my $emacsenname = exists $lang->{"emacsen-name"} ?
  285.       $lang->{"emacsen-name"} : $hashname;
  286.  
  287.       # Explicitly add " -d $hashname" to $ispellargs if not already there.
  288.       # Note that this must check for "-dxx", "-d xx", "-C -d xx", "-C -dxx" like matches
  289.       if ( $ispellargs !~ m/( |^)-d/ ){
  290.     print STDERR " - $class-emacsen: Adding \" -d $hashname\" to \"$ispellargs\"\n"
  291.       if defined $ENV{'DICT_COMMON_DEBUG'};
  292.     $ispellargs .= " -d $hashname";
  293.       }
  294.  
  295.       $entries{$class}{$emacsenname} = $entries{'all'}{$emacsenname} =
  296.       ['"' . $emacsenname  . '"',
  297.        '"' . $casechars    . '"',
  298.        '"' . $notcasechars . '"',
  299.        '"' . $otherchars   . '"',
  300.        $manyothercharsp,
  301.        '("' . join ('" "', split (/\s+/,$ispellargs)) . '")',
  302.        $extendedcharactermode,
  303.        $codingsystem];
  304.  
  305.       if ( $class eq "aspell" && exists $lang->{"aspell-locales"} ){
  306.     foreach ( split(/\s*,\s*/,$lang->{"aspell-locales"}) ){
  307.       $class_locales{"aspell"}{$_} = $emacsenname;
  308.     }
  309.       } elsif ( $class eq "hunspell" && exists $lang->{"hunspell-locales"} ){
  310.     foreach ( split(/\s*,\s*/,$lang->{"hunspell-locales"}) ){
  311.       $class_locales{"hunspell"}{$_} = $emacsenname;
  312.     }
  313.       }
  314.     }
  315.   }
  316.  
  317.   # Write alists of ispell, hunspell and aspell only installed dicts and their properties
  318.  
  319.   foreach $class ( @classes ) {
  320.     my @class_dicts = reverse sort keys %{ $entries{$class} };
  321.     if ( scalar @class_dicts ){
  322.       $elisp .= "\n;; Adding $class dicts\n\n";
  323.       foreach ( @class_dicts ){
  324.     my $mystring = join ("\n     ",@{ $entries{$class}{$_} });
  325.     $elisp .= "(add-to-list \'debian-$class-only-dictionary-alist\n  \'($mystring))\n";
  326.       }
  327.       $elisp .= "\n";
  328.     }
  329.   }
  330.  
  331.   # Write a list of locales associated to each emacsen name
  332.  
  333.   foreach my $class ("aspell", "hunspell"){
  334.     my $tmp_locales = $class_locales{$class};
  335.     if ( defined $tmp_locales && scalar %$tmp_locales ){
  336.       $elisp .= "\n\n;; An alist that will try to map $class locales to emacsen names";
  337.       $elisp .= "\n\n(setq debian-$class-equivs-alist \'(\n";
  338.       foreach ( sort keys %$tmp_locales ){
  339.     $elisp .= "     (\"$_\" \"$tmp_locales->{$_}\")\n";
  340.       }
  341.       $elisp .= "))\n";
  342.  
  343.       # Obtain here debian-aspell-dictionary, after debian-aspell-equivs-alist
  344.       # is loaded
  345.  
  346.       $elisp .="
  347. ;; Get default value for debian-$class-dictionary. Will be used if
  348. ;; spellchecker is $class and ispell-local-dictionary is not set.
  349. ;; We need to get it here, after debian-$class-equivs-alist is loaded
  350.  
  351. (setq debian-$class-dictionary (debian-ispell-get-$class-default))\n\n";
  352.    } else {
  353.       $elisp .= "\n\n;; No emacsen-$class-equivs entries were found\n";
  354.    }}
  355.  
  356.   open (ELISP, "> $cachedir/$emacsensupport")
  357.       or die "Cannot open emacsen cache file";
  358.   print ELISP generate_comment (";;; ");
  359.   print ELISP $elisp;
  360.   close ELISP;
  361. }
  362.  
  363. # ------------------------------------------------------------------
  364. sub build_jed_support {
  365. # ------------------------------------------------------------------
  366. # Put info from dicts info files into jed-ispell-dicts.sl
  367. # ------------------------------------------------------------------
  368.  
  369.   my @classes = ("aspell","ispell");
  370.   my $slang   = generate_comment ("%%% ");
  371.  
  372.   ## The S-Lang code generated below will be wrapped in preprocessor
  373.   ## ifexists constructs, insuring that the $jedsupport file will
  374.   ## always evaluate correctly.
  375.  
  376.   foreach $class ( @classes ){
  377.     my %class_slang    = ();
  378.     my %class_slang_u8 = ();
  379.     if ( my $dictionaries = loaddb ($class) ){
  380.       foreach $k (sort keys %$dictionaries) {
  381.     my $lang = $dictionaries->{$k};
  382.     next if (exists $lang->{'jed-display'}
  383.          && $lang->{'jed-display'} eq "no");
  384.  
  385.     my $hashname = $lang->{"hash-name"};
  386.     my $additionalchars = exists $lang->{additionalchars} ?
  387.         $lang->{additionalchars} : "";
  388.     my $otherchars = exists $lang->{otherchars} ?
  389.         $lang->{otherchars} : "'";
  390.     my $emacsenname = exists $lang->{"emacsen-name"} ?
  391.         $lang->{"emacsen-name"} : $hashname;
  392.     my $extendedcharmode = exists $lang->{"extended-character-mode"} ?
  393.         $lang->{"extended-character-mode"} : "";
  394.     my $ispellargs = exists $lang->{"ispell-args"} ?
  395.         $lang->{"ispell-args"} : "";
  396.     my $codingsystem = exists $lang->{"coding-system"} ?
  397.         $lang->{"coding-system"} : "l1";
  398.  
  399.     # Strip enclosing [] from $otherchars
  400.     $otherchars =~ s/^\[//;
  401.     $otherchars =~ s/\]$//;
  402.     # Convert chars in octal \xxx representation to the character
  403.     $otherchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
  404.     $additionalchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
  405.  
  406.     $class_slang{$emacsenname} =
  407.         "  $class" . "_add_dictionary (\n"
  408.         . "    \"$emacsenname\",\n"
  409.         . "    \"$hashname\",\n"
  410.         . "    \"$additionalchars\",\n"
  411.         . "    \"$otherchars\",\n"
  412.         . ($class eq "ispell" ? "    \"$extendedcharmode\",\n" : "")
  413.         . "    \"$ispellargs\");";
  414.     if ( $class eq "aspell" ){
  415.       my $converter = Text::Iconv->new ($codingsystem, "utf8");
  416.       my $additionalchars_utf = $converter->convert ($additionalchars);
  417.       my $otherchars_utf = $converter->convert ($otherchars);
  418.       $class_slang_u8{$emacsenname} =
  419.           qq{    aspell_add_dictionary (
  420.       "$emacsenname",
  421.       "$hashname",
  422.       "$additionalchars_utf",
  423.       "$otherchars_utf",
  424.       "$ispellargs");};
  425.     } # if $class ..
  426.       } # foreach $k ..
  427.     } # if loaddb ..
  428.     if ( scalar keys %class_slang ){
  429.       $slang .= "\n\#ifexists $class" . "_add_dictionary\n";
  430.       if ( $class eq "aspell" ){
  431.     $slang .= "  if (_slang_utf8_ok) {\n"
  432.         . join("\n",sort values %class_slang_u8)
  433.         . "\n  } else {\n"
  434.         . join("\n",sort values %class_slang)
  435.         . "\n  }";
  436.       } else {
  437.     $slang .= join("\n",sort values %class_slang);
  438.       }
  439.       $slang .= "\n\#endif\n";
  440.     }
  441.   } # foreach $class
  442.   open (SLANG, "> $cachedir/$jedsupport")
  443.       or die "Cannot open jed cache file";
  444.   print SLANG $slang;
  445.   close SLANG;
  446. }
  447.  
  448. # ------------------------------------------------------------------
  449. sub build_squirrelmail_support {
  450. # ------------------------------------------------------------------
  451. # Build support file for squirrelmail with a list of available
  452. # dictionaries and associated spellchecker calls, in php format.
  453. # ------------------------------------------------------------------
  454.   my @classes      = ("aspell","ispell","hunspell");
  455.   my $php          = "<?php\n";
  456.   my @dictlist     = ();
  457.  
  458.   $php .= generate_comment ("### ");
  459.   $php .= "\$SQSPELL_APP = array (\n";
  460.  
  461.   foreach my $class (@classes) {
  462.     my $dictionaries = loaddb ($class);
  463.     foreach ( keys %$dictionaries ){
  464.       next if m/.*[^a-z]tex[^a-z]/i;            # Discard tex variants
  465.       my $lang = $dictionaries->{$_};
  466.       my $squirrelname;
  467.       if ( defined $lang->{"squirrelmail"} ){
  468.     next if ( lc($lang->{"squirrelmail"}) eq "no" );
  469.     $squirrelname = $lang->{"squirrelmail"};
  470.       } else {
  471.     next unless m/^(.*)\((.+)\)$/;
  472.     $squirrelname = $2;
  473.       }
  474.       my $spellchecker_params =
  475.     &dc_get_spellchecker_params($class,$lang);
  476.       push @dictlist, qq {  '$squirrelname ($class)' => '$class -a $spellchecker_params'};
  477.     }
  478.   }
  479.  
  480.   $php .= join(",\n", sort @dictlist);
  481.   $php .= "\n);\n";
  482.  
  483.   open (PHP, "> $cachedir/$squirrelmailsupport")
  484.       or die "Cannot open SquirrelMail cache file";
  485.   print PHP $php;
  486.   close PHP;
  487. }
  488.  
  489. # Ensure we evaluate to true.
  490. 1;
  491.  
  492. __END__
  493.  
  494. #Local Variables:
  495. #perl-indent-level: 2
  496. #End:
  497.  
  498. =head1 NAME
  499.  
  500. Debian::DictionariesCommon.pm - dictionaries-common library
  501.  
  502. =head1 SYNOPSIS
  503.  
  504.     use Debian::DictionariesCommon q(:all)
  505.     $dictionaries = parseinfo ('/var/lib/dictionaries-common/ispell/iwolof');
  506.     loaddb ('ispell')
  507.     updatedb ('wordlist')
  508.  
  509. =head1 DESCRIPTION
  510.  
  511. Common functions for use from the dictionaries-common system.
  512.  
  513. =head1 CALLING FUNCTIONS
  514.  
  515. =over
  516.  
  517. =item C<dico_checkroot>
  518.  
  519. Check for rootness and fail if not.
  520.  
  521. =item C<build_emacsen_support>
  522.  
  523. Put info from dicts info files into emacsen-ispell-dicts.el
  524.  
  525. =item C<build_jed_support>
  526.  
  527. Put info from dicts info files into jed-ispell-dicts.sl
  528.  
  529. =item C<build_squirrelmail_support>
  530.  
  531. Build support file for squirrelmail with a list of available
  532. dictionaries and associated spellchecker calls, in php format.
  533.  
  534. =item C<$libdir = getlibdir($class)>
  535.  
  536. Return info dir for given class.
  537.  
  538. =item C<$default = getsysdefault>
  539.  
  540. Return value for system default ispell dictionary.
  541.  
  542. =item C<$libdir = getuserdefault>
  543.  
  544. Return value for user default ispell dictionary.
  545.  
  546. =item C<dc_get_spellchecker_params($class,\%language)>
  547.  
  548. Get right params for $class (currently unused) and $language
  549.  
  550. =item C<\%dictionaries = loaddb($class)>
  551.  
  552. Read class .db file and return a reference to a hash
  553. with its contents.
  554.  
  555. =item C<\%result = parseinfo($file)>
  556.  
  557. Parse given info file and return a reference to a hash with
  558. the relevant data.
  559.  
  560. =item C<setsysdefault($value)>
  561.  
  562. Set value for system default ispell dictionary.
  563.  
  564. =item C<setuserdefault>
  565.  
  566. Set value for user default ispell dictionary, after asking
  567. to select it from the available values.
  568.  
  569. =item C<updatedb($class)>
  570.  
  571. Parse info files for given class and update class .db
  572. file under dictionaries-common cache dir.
  573.  
  574. =back
  575.  
  576. =head1 SEE ALSO
  577.  
  578. Debian dictionaries-common policy.
  579.  
  580. =head1 AUTHORS
  581.  
  582.  Rafael Laboissiere
  583.  Agustin Martin
  584.  
  585. =cut
  586.